home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / TIMING.LSP < prev    next >
Encoding:
Text File  |  1986-12-22  |  4.0 KB  |  118 lines
  1. ;  timimg routines
  2.  
  3. (defconstant internal-time-units-per-second 100)
  4.  
  5. (defun get-internal-run-time ()
  6.   (multiple-value-bind (ignore1 ignore2 ignore3 cx dx)
  7.       (sys:%sysint #x21 #x2c00 0 0 0)
  8.     (+ (* (lsh cx -8)      60 60 100)
  9.        (* (logand cx #xFF)    60 100)
  10.        (* (lsh dx -8)            100)
  11.        (logand dx #xFF))))
  12.  
  13. (defun timed-duration (fn)
  14.   (let ((start-run (get-internal-run-time)))
  15.     (funcall fn)
  16.     (let ((end-run (get-internal-run-time)))
  17.       (float (/ (- end-run start-run) internal-time-units-per-second)))))
  18.  
  19. (defparameter *minimum-tests* 1)
  20. (defparameter *minimum-duration* 10.0)
  21.  
  22. (defun multiple-timed-duration (fn)
  23.   (let* ((total-run-time (timed-duration fn))
  24.   (repeats (max *minimum-tests*
  25.          (ceiling *minimum-duration*
  26.     (if (zerop total-run-time) 1
  27.         total-run-time)))))
  28.     (do ((count repeats (- count 1)))
  29.  ((< count 2) (values total-run-time repeats))
  30.       (incf total-run-time (timed-duration fn)))))
  31.  
  32. (defvar *all-timers* nil)
  33. (defvar *bad-timers* '(tak boyer))
  34.  
  35. (defmacro define-timer (name documentation &body body)
  36.   `(progn (pushnew ',name *all-timers*)
  37.    (setf (get ',name 'timing-function)
  38.   ,(if (and (= (length body) 1) (= (length (first body)) 1))
  39.        (list 'quote (first (first body)))
  40.        `#'(lambda () . ,body)))
  41.    (setf (get ',name 'timing-documentation) ,documentation)))
  42.  
  43. (defun run-tests (&optional file)
  44.   (if (null file) (run-tests1 't)
  45.       (with-open-file (stream file :direction :output) (run-tests1 stream))))
  46.  
  47. (defun run-tests1 (stream)
  48.   (describe-implementation stream)
  49.   (do ((tests *all-timers* (cdr tests))) ((null tests) '*)
  50.     (cond ((member (first tests) *bad-timers*)
  51.     (format stream "~&Run of ~A punted due to stack group reset.~%"
  52.      (get (first tests) 'timing-documentation)))
  53.    (t (sys::gc)
  54.       (multiple-value-bind (answer error?)
  55.           (ignore-errors (run-one (first tests) stream))
  56.         (if error? (format stream "~%    ERROR: ~A~%" error?)))))))
  57.  
  58. (defun run-one (name &optional (stream *terminal-io*))
  59.   (unless (get name 'timing-documentation)
  60.     (error "~&There's no such benchmark as ~S.~%" name))
  61.   (format stream "~&Running ~A . . ." (get name 'timing-documentation))
  62.   (multiple-value-bind (time n-runs)
  63.       (multiple-timed-duration (get name 'timing-function))
  64.     (format stream "~%    time: ~D seconds (based on ~D call"
  65.      (/ time n-runs) n-runs)
  66.     (unless (= n-runs 1) (write-char #\s stream))
  67.     (format stream ")~%" time n-runs)))
  68.  
  69. (defun describe-implementation (&optional (stream *standard-output*))
  70.   (format stream "~&Lisp Type:     ~A" (lisp-implementation-type))
  71.   (format stream "~&Lisp Version:  ~A" (lisp-implementation-version))
  72.   #+:Large-Memory
  73.   (format stream "~&Machine Type:  IBM-PC/AT")
  74.   #-:Large-Memory
  75.   (format stream "~&Machine Type:  IBM-PC/XT")
  76.   (format stream "~&Features:      ~A" (car *features*))
  77.   (if (cdr *features*) (format stream ", "))
  78.   (do ((features (cdr *features*) (cdr features))
  79.        (offset (+ 17 (length (string (car *features*))))))
  80.       ((null features))
  81.     (let* ((feature (string (car features))) (lth (length feature)))
  82.       (cond ((> (setq offset (+ offset 2 lth)) 76)
  83.       (setq offset (+ 15 lth))
  84.       (format stream "~&               ~A" feature))
  85.      (t (format stream "~A" feature)))
  86.       (when (cdr features)
  87.  (setq offset (+ offset 2))
  88.  (format stream ", "))))
  89.   (format stream "~%~%"))
  90.  
  91.  
  92. (defvar *benchmark-files*
  93.  '("DESTRUCT"                
  94.    "IO"                    
  95.    "FRPOLY"                
  96.    "TRIANG"                
  97.    ;"PUZZLE"                
  98.    ;"FFT"                    
  99.    "DIV"                    
  100.    "DERIV"                
  101.    "TRAVERSE"                
  102.    "BROWSE"                
  103.    "BOYER"                
  104.    "TAK"                    
  105.    ))
  106.  
  107.  
  108. (defmacro qa-attempt (&body stuff) (list 'quote stuff))
  109.  
  110. (defun benchmark-file (file) (merge-pathnames "C:>GCLISP2>" file))
  111.  
  112. (defun load-benchmark-files ()
  113.   (mapc #'(lambda (file) (load (benchmark-file file))) *benchmark-files*))
  114.  
  115. (defun compile-benchmark-files (&optional load?)
  116.   (mapc #'(lambda (file) (compile-file (benchmark-file file) :load load?))
  117.     *benchmark-files*))
  118.